home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / ExtUtils / Constant.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  14.4 KB  |  562 lines
  1. package ExtUtils::Constant;
  2. use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS);
  3. $VERSION = 0.20;
  4.  
  5. =head1 NAME
  6.  
  7. ExtUtils::Constant - generate XS code to import C header constants
  8.  
  9. =head1 SYNOPSIS
  10.  
  11.     use ExtUtils::Constant qw (WriteConstants);
  12.     WriteConstants(
  13.         NAME => 'Foo',
  14.         NAMES => [qw(FOO BAR BAZ)],
  15.     );
  16.     # Generates wrapper code to make the values of the constants FOO BAR BAZ
  17.     #  available to perl
  18.  
  19. =head1 DESCRIPTION
  20.  
  21. ExtUtils::Constant facilitates generating C and XS wrapper code to allow
  22. perl modules to AUTOLOAD constants defined in C library header files.
  23. It is principally used by the C<h2xs> utility, on which this code is based.
  24. It doesn't contain the routines to scan header files to extract these
  25. constants.
  26.  
  27. =head1 USAGE
  28.  
  29. Generally one only needs to call the C<WriteConstants> function, and then
  30.  
  31.     #include "const-c.inc"
  32.  
  33. in the C section of C<Foo.xs>
  34.  
  35.     INCLUDE: const-xs.inc
  36.  
  37. in the XS section of C<Foo.xs>.
  38.  
  39. For greater flexibility use C<constant_types()>, C<C_constant> and
  40. C<XS_constant>, with which C<WriteConstants> is implemented.
  41.  
  42. Currently this module understands the following types. h2xs may only know
  43. a subset. The sizes of the numeric types are chosen by the C<Configure>
  44. script at compile time.
  45.  
  46. =over 4
  47.  
  48. =item IV
  49.  
  50. signed integer, at least 32 bits.
  51.  
  52. =item UV
  53.  
  54. unsigned integer, the same size as I<IV>
  55.  
  56. =item NV
  57.  
  58. floating point type, probably C<double>, possibly C<long double>
  59.  
  60. =item PV
  61.  
  62. NUL terminated string, length will be determined with C<strlen>
  63.  
  64. =item PVN
  65.  
  66. A fixed length thing, given as a [pointer, length] pair. If you know the
  67. length of a string at compile time you may use this instead of I<PV>
  68.  
  69. =item SV
  70.  
  71. A B<mortal> SV.
  72.  
  73. =item YES
  74.  
  75. Truth.  (C<PL_sv_yes>)  The value is not needed (and ignored).
  76.  
  77. =item NO
  78.  
  79. Defined Falsehood.  (C<PL_sv_no>)  The value is not needed (and ignored).
  80.  
  81. =item UNDEF
  82.  
  83. C<undef>.  The value of the macro is not needed.
  84.  
  85. =back
  86.  
  87. =head1 FUNCTIONS
  88.  
  89. =over 4
  90.  
  91. =cut
  92.  
  93. if ($] >= 5.006) {
  94.   eval "use warnings; 1" or die $@;
  95. }
  96. use strict;
  97. use Carp qw(croak cluck);
  98.  
  99. use Exporter;
  100. use ExtUtils::Constant::Utils qw(C_stringify);
  101. use ExtUtils::Constant::XS qw(%XS_Constant %XS_TypeSet);
  102.  
  103. @ISA = 'Exporter';
  104.  
  105. %EXPORT_TAGS = ( 'all' => [ qw(
  106.     XS_constant constant_types return_clause memEQ_clause C_stringify
  107.     C_constant autoload WriteConstants WriteMakefileSnippet
  108. ) ] );
  109.  
  110. @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
  111.  
  112. =item constant_types
  113.  
  114. A function returning a single scalar with C<#define> definitions for the
  115. constants used internally between the generated C and XS functions.
  116.  
  117. =cut
  118.  
  119. sub constant_types {
  120.   ExtUtils::Constant::XS->header();
  121. }
  122.  
  123. sub memEQ_clause {
  124.   cluck "ExtUtils::Constant::memEQ_clause is deprecated";
  125.   ExtUtils::Constant::XS->memEQ_clause({name=>$_[0], checked_at=>$_[1],
  126.                     indent=>$_[2]});
  127. }
  128.  
  129. sub return_clause ($$) {
  130.   cluck "ExtUtils::Constant::return_clause is deprecated";
  131.   my $indent = shift;
  132.   ExtUtils::Constant::XS->return_clause({indent=>$indent}, @_);
  133. }
  134.  
  135. sub switch_clause {
  136.   cluck "ExtUtils::Constant::switch_clause is deprecated";
  137.   my $indent = shift;
  138.   my $comment = shift;
  139.   ExtUtils::Constant::XS->switch_clause({indent=>$indent, comment=>$comment},
  140.                     @_);
  141. }
  142.  
  143. sub C_constant {
  144.   my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
  145.     = @_;
  146.   ExtUtils::Constant::XS->C_constant({package => $package, subname => $subname,
  147.                       default_type => $default_type,
  148.                       types => $what, indent => $indent,
  149.                       breakout => $breakout}, @items);
  150. }
  151.  
  152. =item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME
  153.  
  154. A function to generate the XS code to implement the perl subroutine
  155. I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants.
  156. This XS code is a wrapper around a C subroutine usually generated by
  157. C<C_constant>, and usually named C<constant>.
  158.  
  159. I<TYPES> should be given either as a comma separated list of types that the
  160. C subroutine C<constant> will generate or as a reference to a hash. It should
  161. be the same list of types as C<C_constant> was given.
  162. [Otherwise C<XS_constant> and C<C_constant> may have different ideas about
  163. the number of parameters passed to the C function C<constant>]
  164.  
  165. You can call the perl visible subroutine something other than C<constant> if
  166. you give the parameter I<SUBNAME>. The C subroutine it calls defaults to
  167. the name of the perl visible subroutine, unless you give the parameter
  168. I<C_SUBNAME>.
  169.  
  170. =cut
  171.  
  172. sub XS_constant {
  173.   my $package = shift;
  174.   my $what = shift;
  175.   my $subname = shift;
  176.   my $C_subname = shift;
  177.   $subname ||= 'constant';
  178.   $C_subname ||= $subname;
  179.  
  180.   if (!ref $what) {
  181.     # Convert line of the form IV,UV,NV to hash
  182.     $what = {map {$_ => 1} split /,\s*/, ($what)};
  183.   }
  184.   my $params = ExtUtils::Constant::XS->params ($what);
  185.   my $type;
  186.  
  187.   my $xs = <<"EOT";
  188. void
  189. $subname(sv)
  190.     PREINIT:
  191. #ifdef dXSTARG
  192.     dXSTARG; /* Faster if we have it.  */
  193. #else
  194.     dTARGET;
  195. #endif
  196.     STRLEN        len;
  197.         int        type;
  198. EOT
  199.  
  200.   if ($params->{IV}) {
  201.     $xs .= "    IV        iv;\n";
  202.   } else {
  203.     $xs .= "    /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
  204.   }
  205.   if ($params->{NV}) {
  206.     $xs .= "    NV        nv;\n";
  207.   } else {
  208.     $xs .= "    /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
  209.   }
  210.   if ($params->{PV}) {
  211.     $xs .= "    const char    *pv;\n";
  212.   } else {
  213.     $xs .=
  214.       "    /* const char\t*pv;\tUncomment this if you need to return PVs */\n";
  215.   }
  216.  
  217.   $xs .= << 'EOT';
  218.     INPUT:
  219.     SV *        sv;
  220.         const char *    s = SvPV(sv, len);
  221. EOT
  222.   if ($params->{''}) {
  223.   $xs .= << 'EOT';
  224.     INPUT:
  225.     int        utf8 = SvUTF8(sv);
  226. EOT
  227.   }
  228.   $xs .= << 'EOT';
  229.     PPCODE:
  230. EOT
  231.  
  232.   if ($params->{IV} xor $params->{NV}) {
  233.     $xs .= << "EOT";
  234.         /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
  235.            if you need to return both NVs and IVs */
  236. EOT
  237.   }
  238.   $xs .= "    type = $C_subname(aTHX_ s, len";
  239.   $xs .= ', utf8' if $params->{''};
  240.   $xs .= ', &iv' if $params->{IV};
  241.   $xs .= ', &nv' if $params->{NV};
  242.   $xs .= ', &pv' if $params->{PV};
  243.   $xs .= ', &sv' if $params->{SV};
  244.   $xs .= ");\n";
  245.  
  246.   # If anyone is insane enough to suggest a package name containing %
  247.   my $package_sprintf_safe = $package;
  248.   $package_sprintf_safe =~ s/%/%%/g;
  249.  
  250.   $xs .= << "EOT";
  251.       /* Return 1 or 2 items. First is error message, or undef if no error.
  252.            Second, if present, is found value */
  253.         switch (type) {
  254.         case PERL_constant_NOTFOUND:
  255.           sv =
  256.         sv_2mortal(newSVpvf("%s is not a valid $package_sprintf_safe macro", s));
  257.           PUSHs(sv);
  258.           break;
  259.         case PERL_constant_NOTDEF:
  260.           sv = sv_2mortal(newSVpvf(
  261.         "Your vendor has not defined $package_sprintf_safe macro %s, used",
  262.                    s));
  263.           PUSHs(sv);
  264.           break;
  265. EOT
  266.  
  267.   foreach $type (sort keys %XS_Constant) {
  268.     # '' marks utf8 flag needed.
  269.     next if $type eq '';
  270.     $xs .= "\t/* Uncomment this if you need to return ${type}s\n"
  271.       unless $what->{$type};
  272.     $xs .= "        case PERL_constant_IS$type:\n";
  273.     if (length $XS_Constant{$type}) {
  274.       $xs .= << "EOT";
  275.           EXTEND(SP, 1);
  276.           PUSHs(&PL_sv_undef);
  277.           $XS_Constant{$type};
  278. EOT
  279.     } else {
  280.       # Do nothing. return (), which will be correctly interpreted as
  281.       # (undef, undef)
  282.     }
  283.     $xs .= "          break;\n";
  284.     unless ($what->{$type}) {
  285.       chop $xs; # Yes, another need for chop not chomp.
  286.       $xs .= " */\n";
  287.     }
  288.   }
  289.   $xs .= << "EOT";
  290.         default:
  291.           sv = sv_2mortal(newSVpvf(
  292.         "Unexpected return type %d while processing $package_sprintf_safe macro %s, used",
  293.                type, s));
  294.           PUSHs(sv);
  295.         }
  296. EOT
  297.  
  298.   return $xs;
  299. }
  300.  
  301.  
  302. =item autoload PACKAGE, VERSION, AUTOLOADER
  303.  
  304. A function to generate the AUTOLOAD subroutine for the module I<PACKAGE>
  305. I<VERSION> is the perl version the code should be backwards compatible with.
  306. It defaults to the version of perl running the subroutine.  If I<AUTOLOADER>
  307. is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all
  308. names that the constant() routine doesn't recognise.
  309.  
  310. =cut
  311.  
  312. # ' # Grr. syntax highlighters that don't grok pod.
  313.  
  314. sub autoload {
  315.   my ($module, $compat_version, $autoloader) = @_;
  316.   $compat_version ||= $];
  317.   croak "Can't maintain compatibility back as far as version $compat_version"
  318.     if $compat_version < 5;
  319.   my $func = "sub AUTOLOAD {\n"
  320.   . "    # This AUTOLOAD is used to 'autoload' constants from the constant()\n"
  321.   . "    # XS function.";
  322.   $func .= "  If a constant is not found then control is passed\n"
  323.   . "    # to the AUTOLOAD in AutoLoader." if $autoloader;
  324.  
  325.  
  326.   $func .= "\n\n"
  327.   . "    my \$constname;\n";
  328.   $func .=
  329.     "    our \$AUTOLOAD;\n"  if ($compat_version >= 5.006);
  330.  
  331.   $func .= <<"EOT";
  332.     (\$constname = \$AUTOLOAD) =~ s/.*:://;
  333.     croak "&${module}::constant not defined" if \$constname eq 'constant';
  334.     my (\$error, \$val) = constant(\$constname);
  335. EOT
  336.  
  337.   if ($autoloader) {
  338.     $func .= <<'EOT';
  339.     if ($error) {
  340.     if ($error =~  /is not a valid/) {
  341.         $AutoLoader::AUTOLOAD = $AUTOLOAD;
  342.         goto &AutoLoader::AUTOLOAD;
  343.     } else {
  344.         croak $error;
  345.     }
  346.     }
  347. EOT
  348.   } else {
  349.     $func .=
  350.       "    if (\$error) { croak \$error; }\n";
  351.   }
  352.  
  353.   $func .= <<'END';
  354.     {
  355.     no strict 'refs';
  356.     # Fixed between 5.005_53 and 5.005_61
  357. #XXX    if ($] >= 5.00561) {
  358. #XXX        *$AUTOLOAD = sub () { $val };
  359. #XXX    }
  360. #XXX    else {
  361.         *$AUTOLOAD = sub { $val };
  362. #XXX    }
  363.     }
  364.     goto &$AUTOLOAD;
  365. }
  366.  
  367. END
  368.  
  369.   return $func;
  370. }
  371.  
  372.  
  373. =item WriteMakefileSnippet
  374.  
  375. WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...] 
  376.  
  377. A function to generate perl code for Makefile.PL that will regenerate
  378. the constant subroutines.  Parameters are named as passed to C<WriteConstants>,
  379. with the addition of C<INDENT> to specify the number of leading spaces
  380. (default 2).
  381.  
  382. Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and
  383. C<XS_FILE> are recognised.
  384.  
  385. =cut
  386.  
  387. sub WriteMakefileSnippet {
  388.   my %args = @_;
  389.   my $indent = $args{INDENT} || 2;
  390.  
  391.   my $result = <<"EOT";
  392. ExtUtils::Constant::WriteConstants(
  393.                                    NAME         => '$args{NAME}',
  394.                                    NAMES        => \\\@names,
  395.                                    DEFAULT_TYPE => '$args{DEFAULT_TYPE}',
  396. EOT
  397.   foreach (qw (C_FILE XS_FILE)) {
  398.     next unless exists $args{$_};
  399.     $result .= sprintf "                                   %-12s => '%s',\n",
  400.       $_, $args{$_};
  401.   }
  402.   $result .= <<'EOT';
  403.                                 );
  404. EOT
  405.  
  406.   $result =~ s/^/' 'x$indent/gem;
  407.   return ExtUtils::Constant::XS->dump_names({default_type=>$args{DEFAULT_TYPE},
  408.                          indent=>$indent,},
  409.                         @{$args{NAMES}})
  410.     . $result;
  411. }
  412.  
  413. =item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...]
  414.  
  415. Writes a file of C code and a file of XS code which you should C<#include>
  416. and C<INCLUDE> in the C and XS sections respectively of your module's XS
  417. code.  You probably want to do this in your C<Makefile.PL>, so that you can
  418. easily edit the list of constants without touching the rest of your module.
  419. The attributes supported are
  420.  
  421. =over 4
  422.  
  423. =item NAME
  424.  
  425. Name of the module.  This must be specified
  426.  
  427. =item DEFAULT_TYPE
  428.  
  429. The default type for the constants.  If not specified C<IV> is assumed.
  430.  
  431. =item BREAKOUT_AT
  432.  
  433. The names of the constants are grouped by length.  Generate child subroutines
  434. for each group with this number or more names in.
  435.  
  436. =item NAMES
  437.  
  438. An array of constants' names, either scalars containing names, or hashrefs
  439. as detailed in L<"C_constant">.
  440.  
  441. =item C_FH
  442.  
  443. A filehandle to write the C code to.  If not given, then I<C_FILE> is opened
  444. for writing.
  445.  
  446. =item C_FILE
  447.  
  448. The name of the file to write containing the C code.  The default is
  449. C<const-c.inc>.  The C<-> in the name ensures that the file can't be
  450. mistaken for anything related to a legitimate perl package name, and
  451. not naming the file C<.c> avoids having to override Makefile.PL's
  452. C<.xs> to C<.c> rules.
  453.  
  454. =item XS_FH
  455.  
  456. A filehandle to write the XS code to.  If not given, then I<XS_FILE> is opened
  457. for writing.
  458.  
  459. =item XS_FILE
  460.  
  461. The name of the file to write containing the XS code.  The default is
  462. C<const-xs.inc>.
  463.  
  464. =item SUBNAME
  465.  
  466. The perl visible name of the XS subroutine generated which will return the
  467. constants. The default is C<constant>.
  468.  
  469. =item C_SUBNAME
  470.  
  471. The name of the C subroutine generated which will return the constants.
  472. The default is I<SUBNAME>.  Child subroutines have C<_> and the name
  473. length appended, so constants with 10 character names would be in
  474. C<constant_10> with the default I<XS_SUBNAME>.
  475.  
  476. =back
  477.  
  478. =cut
  479.  
  480. sub WriteConstants {
  481.   my %ARGS =
  482.     ( # defaults
  483.      C_FILE =>       'const-c.inc',
  484.      XS_FILE =>      'const-xs.inc',
  485.      SUBNAME =>      'constant',
  486.      DEFAULT_TYPE => 'IV',
  487.      @_);
  488.  
  489.   $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
  490.  
  491.   croak "Module name not specified" unless length $ARGS{NAME};
  492.  
  493.   my $c_fh = $ARGS{C_FH};
  494.   if (!$c_fh) {
  495.       if ($] <= 5.008) {
  496.       # We need these little games, rather than doing things
  497.       # unconditionally, because we're used in core Makefile.PLs before
  498.       # IO is available (needed by filehandle), but also we want to work on
  499.       # older perls where undefined scalars do not automatically turn into
  500.       # anonymous file handles.
  501.       require FileHandle;
  502.       $c_fh = FileHandle->new();
  503.       }
  504.       open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
  505.   }
  506.  
  507.   my $xs_fh = $ARGS{XS_FH};
  508.   if (!$xs_fh) {
  509.       if ($] <= 5.008) {
  510.       require FileHandle;
  511.       $xs_fh = FileHandle->new();
  512.       }
  513.       open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!";
  514.   }
  515.  
  516.   # As this subroutine is intended to make code that isn't edited, there's no
  517.   # need for the user to specify any types that aren't found in the list of
  518.   # names.
  519.   
  520.   if ($ARGS{PROXYSUBS}) {
  521.       require ExtUtils::Constant::ProxySubs;
  522.       $ARGS{C_FH} = $c_fh;
  523.       $ARGS{XS_FH} = $xs_fh;
  524.       ExtUtils::Constant::ProxySubs->WriteConstants(%ARGS);
  525.   } else {
  526.       my $types = {};
  527.  
  528.       print $c_fh constant_types(); # macro defs
  529.       print $c_fh "\n";
  530.  
  531.       # indent is still undef. Until anyone implements indent style rules with
  532.       # it.
  533.       foreach (ExtUtils::Constant::XS->C_constant({package => $ARGS{NAME},
  534.                            subname => $ARGS{C_SUBNAME},
  535.                            default_type =>
  536.                                $ARGS{DEFAULT_TYPE},
  537.                                types => $types,
  538.                                breakout =>
  539.                                $ARGS{BREAKOUT_AT}},
  540.                           @{$ARGS{NAMES}})) {
  541.       print $c_fh $_, "\n"; # C constant subs
  542.       }
  543.       print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME},
  544.                 $ARGS{C_SUBNAME});
  545.   }
  546.  
  547.   close $c_fh or warn "Error closing $ARGS{C_FILE}: $!" unless $ARGS{C_FH};
  548.   close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!" unless $ARGS{XS_FH};
  549. }
  550.  
  551. 1;
  552. __END__
  553.  
  554. =back
  555.  
  556. =head1 AUTHOR
  557.  
  558. Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and
  559. others
  560.  
  561. =cut
  562.